Game of Life - fbForth Version
ported from code at http://www.forth-ev.de/wiki/doku.php/projects:4e4th:4e4th:start:beispiele)



( Compatibility Harness: )
DECIMAL
: INVERT ( n -- 'n )
    ( return 1s compliment of n )
    65535 - MINUS ;
    
: 2* ( n -- 2n )
    2 * ;
    
: CELLS ( n -- 2n )
    2 * ;
    
: PICK ( index -- n )
    1+ 2 * SP@ + @ ;
   
    

 
( LIFE: fbForth )

16 CONSTANT #lines
8 CELLS CONSTANT b/cell  ( bits per cell: = number of columns)

: line  ( n -- a-addr ) CELLS PAD + ;
: lrot  ( x1 -- x2 )  ( rotate left by one )
   DUP 2* SWAP 0< - ;
: lrot3  ( x1 x2 x3 --  x4 x5 x6 ) lrot ROT  lrot ROT  lrot ROT ;

HERE  0 C, 1 C, 1 C, 2 C,  1 C, 2 C, 2 C, 3 C,  CONSTANT #bits
: countbits  ( x -- n )  ( count number of bits=1 in bit0..2 )
   7 AND #bits + C@ ;

: alive  ( x1 x2 x3 -- flag )
   ( return whether cell at bit1 in line1 is alive in next generation)
   OVER 2 AND 0= INVERT >R
   countbits
   SWAP countbits +  ( note: cell itself is counted, too. correction below.)
   SWAP countbits +
   DUP 3 =  SWAP 4 = R> AND OR ;
   
: 3dup  ( x1 x2 x3 -- x1 x2 x3 x1 x2 x3 )
   2 PICK 2 PICK 2 PICK ;
   
: doline  ( x1 x2 x3 -- x1 x2 x3 x4 )
   0  b/cell 0 DO 
      >R   3dup alive 2 AND R> OR lrot >R
      lrot3   R>
   LOOP ;
   
: nextgen  ( -- )
   0 line @   #lines 1- line @  OVER   ( s: line0   x1 x2 )
   #lines 1- 0 DO
      I 1+ line @               ( s: line0  x1 x2 x3 )
      doline  I line !
      ROT DROP                  ( s: line0  x2 x3 )
   LOOP  
   ROT doline  #lines 1- line ! ( special treatment for last line)
   DROP DROP DROP ;
   
: .line  ( x -- )
   b/cell 0 DO
      DUP 0< IF 64 ( @)  ELSE 46 ( .) THEN EMIT
      lrot
   LOOP  DROP ;
   
0 VARIABLE generation 
: .universe  ( -- )  ( print current life state to console )
    0 0 GOTOXY  #lines 0 DO   CR I line @ .line  LOOP CR 
   generation @ .  1 generation +! ;
   
: LIFE  ( -- )
( run life with output to console, until key <q> pressed )
   GRAPHICS BEGIN
      .universe     nextgen  
   ?KEY 81 ( Q) = UNTIL ;

: VOID  ( -- )  PAD #lines CELLS 0 FILL ;
: seed  ( x1 .. xn n -- )   0 DO I line ! LOOP ;
HEX  ( some wellknown patterns:)
: GLIDER  ( -- )  7 1 2  3 seed ;
: FPENT  ( -- )  4 0C 6  3 seed ;
: LWSS  ( -- )  0F 11 1 12  4 seed ;
: DIEHARD  47 0C0 2  3 seed ;
: ACORN  67 8 20  3 seed ;
: DEMO   GLIDER   700 3 line ! ;
DECIMAL

VOID DEMO LIFE 